Behavioural findings regarding the Illusion Game.
library(tidyverse)
library(ggdist)
library(ggside)
library(easystats)
library(patchwork)
library(brms)
df <- read.csv("data/study1.csv") |>
mutate(
Screen_Refresh = as.character(Screen_Refresh),
Illusion_Side = as.factor(Illusion_Side),
Block = as.factor(Block),
Education = fct_relevel(Education, "Master", "Bachelor", "High School", "Other")
)
outliers <- c(
# Half of the trials are of very short RT
# plot(estimate_density(dfraw[dfraw$Participant == "60684f29dbfe1bb2059e5e27_rkqoy", "RT"]))
"60684f29dbfe1bb2059e5e27_rkqoy",
# Error rate of 47.9%
"61280140171ec546e87ed8cb_qdlgy",
# Error rate of 46.2%
"614f36fd81c78b7a125c4262_6ax4g",
# Error rate of 42.1% and very large RT SD
"5d398380b37ab1000111fac3_2nxxh",
# Block n2 with very short RTs
"5e860198a846e30497df5189_6e43s"
)
We removed 5 participants upon inspection of the average error rage (when close to 50%, suggesting random answers) and/or when the reaction time distribution was implausibly fast.
For each block, we computed the error rate and, if more than 50%, we discarded the whole block (as it likely indicates that instructions got mixed up, for instance participants were selecting the smaller instead of the bigger circle).
dfsub <- df |>
group_by(Participant) |>
summarize(
# n = n(),
Error = sum(Error) / n(),
RT_Mean = mean(RT),
RT_SD = sd(RT),
) |>
ungroup() |>
arrange(desc(Error))
knitr::kable(dfsub) |>
kableExtra::row_spec(which(dfsub$Participant %in% outliers), background = "#EF9A9A")
| Participant | Error | RT_Mean | RT_SD |
|---|---|---|---|
| 61280140171ec546e87ed8cb_qdlgy | 0.479 | 262 | 296 |
| 614f36fd81c78b7a125c4262_6ax4g | 0.462 | 630 | 611 |
| 5d398380b37ab1000111fac3_2nxxh | 0.421 | 507 | 1679 |
| 5e860198a846e30497df5189_6e43s | 0.402 | 492 | 725 |
| 61572ca3e91309ebe876a9db_8cqnp | 0.287 | 659 | 333 |
| 5d9091ff391a60058a7711b5_dvz9e | 0.269 | 578 | 172 |
| 6106b7157977b80c497314f8_d7ukm | 0.260 | 718 | 1294 |
| 60684f29dbfe1bb2059e5e27_rkqoy | 0.251 | 599 | 1326 |
| 611eb7284490ba01cddfbe98_om6zf | 0.246 | 699 | 414 |
| 60d129f2a122e84175a56425_z2w8h | 0.243 | 693 | 232 |
| 5d7389f193a945001a3ea504_nhua6 | 0.238 | 1160 | 1660 |
| 60dae077e62179eb469e32a4_b4pte | 0.227 | 748 | 243 |
| 5c6b0a27ffc824000191c7d8_5ajt1 | 0.225 | 780 | 427 |
| 5ff46a1a99e7cfb2994f7958_f2zg0 | 0.216 | 506 | 150 |
| 5f19559b9665f700090276c4_hsmss | 0.215 | 738 | 375 |
| 5c8ab0f10de08f00016e43a1_pyvgt | 0.213 | 1076 | 557 |
| 6166a03f5063db088c458b73_m7w8f | 0.207 | 804 | 378 |
| 606cd013f538ed55e02069b5_vr3v7 | 0.206 | 652 | 367 |
| 5f480e566265722a9b2b2660_0bola | 0.205 | 511 | 147 |
| 605b60879326739b05897042_bpsyp | 0.203 | 627 | 223 |
| 609193e5a0cea97bf00ac6e2_a6zcr | 0.202 | 1133 | 982 |
| 610b0a1bf2434edb31592209_3f1wq | 0.202 | 869 | 424 |
| 5f08583a3d61a604d606c517_o75t7 | 0.201 | 720 | 298 |
| 55eab7fd748092000daa98f2_f10fa | 0.198 | 1110 | 738 |
| 5e04595a4fa02aefdb9c9ced_n3rey | 0.189 | 983 | 830 |
| 61114f10ae21c59c0ed3d106_jw6v8 | 0.187 | 711 | 195 |
| 5f14886922a7d20725a22cde_9awyt | 0.186 | 803 | 397 |
| 60a6dd8779e3de1097e5d50a_t4wyc | 0.185 | 846 | 765 |
| 5c73e5d89b46930001ee7edc_ydo84 | 0.182 | 1045 | 1082 |
| 5e84f2663a34f20c3907e237_rt0oo | 0.181 | 1001 | 562 |
| 5ebde9baaefecd1325ef23c7_lphsv | 0.176 | 1307 | 1091 |
| 5d59a9d909f4300001de0c3b_l125y | 0.175 | 1146 | 900 |
| 563bb259be9cac0005aab7ab_te1z4 | 0.174 | 703 | 243 |
| 60ba6031b6dde7c5b869bf74_gqplc | 0.173 | 616 | 381 |
| 5dfae1f373d7248254527108_0rb1e | 0.171 | 927 | 550 |
| 60b8e0ec34553723e3d6504d_ju18r | 0.170 | 769 | 312 |
| 5d5051e31025380015dc59b8_dwrdh | 0.157 | 848 | 364 |
| 60366cfe9748fc2b0ccbc9d0_ox8hj | 0.156 | 712 | 383 |
| 5bce155e561901000121006f_49472 | 0.142 | 1109 | 863 |
| 5ccc3dd7a758ba00133c0763_lwl1g | 0.139 | 895 | 816 |
| 5a0b46e0844c7a00015e4d13_jedw6 | 0.124 | 741 | 331 |
| 5eb0205cac7ad4085dc32a50_5xekt | 0.092 | 884 | 509 |
# RT distribution
estimate_density(df, select = "RT", at = c("Participant", "Block")) |>
group_by(Participant) |>
normalize(select = "y") |>
ungroup() |>
mutate(color = ifelse(Participant %in% outliers, "red", "blue")) |>
ggplot(aes(x = x, y = y)) +
geom_area(data = normalize(estimate_density(df, select = "RT"), select = "y"), alpha = 0.2) +
geom_line(aes(color = color, group = interaction(Participant, Block), linetype = Block)) +
geom_vline(xintercept = 2500, linetype = "dashed", color = "red") +
scale_color_manual(values=c("red"="red", "blue"="blue"), guide = "none") +
scale_x_continuous(expand = c(0, 0)) +
scale_y_continuous(expand = c(0, 0)) +
coord_cartesian(xlim = c(0, 3000)) +
theme_modern() +
theme(axis.text.y = element_blank()) +
facet_wrap(~Participant) +
labs(y = "", x = "Reaction Time (ms)")
# Filter out
df <- filter(df, !Participant %in% outliers)
temp <- df |>
group_by(Participant, Illusion_Type, Block) |>
summarize(ErrorRate_per_block = sum(Error) / n()) |>
ungroup() |>
arrange(desc(ErrorRate_per_block))
temp2 <- temp |>
filter(ErrorRate_per_block >= 0.5) |>
group_by(Illusion_Type, Block) |>
summarize(n = n()) |>
arrange(desc(n), Illusion_Type) |>
ungroup() |>
mutate(n_trials = cumsum(n * 56),
p_trials = n_trials / nrow(df))
# knitr::kable(temp2)
p1 <- temp |>
estimate_density(at = c("Illusion_Type", "Block")) |>
ggplot(aes(x = x, y = y)) +
geom_line(aes(color = Illusion_Type, linetype = Block)) +
geom_vline(xintercept = 0.5, linetype = "dashed") +
scale_x_continuous(expand = c(0, 0)) +
scale_y_continuous(expand = c(0, 0)) +
labs(y = "Distribution", x = "Error Rate") +
theme_modern()
p2 <- temp2 |>
mutate(Block = fct_rev(Block)) |>
ggplot(aes(x = Illusion_Type, y = p_trials)) +
geom_bar(stat="identity", aes(fill = Block)) +
scale_x_discrete(expand = c(0, 0)) +
scale_y_continuous(labels = scales::percent, expand = c(0, 0)) +
labs(y = "Percentage of Trials Removed", x = "Illusion Type") +
theme_modern()
p1 | p2
# Drop
df <- df |>
group_by(Participant, Illusion_Type, Block) |>
mutate(ErrorRate_per_block = sum(Error) / n()) |>
ungroup() |>
filter(ErrorRate_per_block < 0.5) |>
select(-ErrorRate_per_block)
rm(temp, temp2)
dfsub <- df |>
group_by(Participant) |>
select(Participant, Age, Sex, Education, Nationality, Ethnicity, Duration, Break_Duration, Screen_Resolution, Screen_Refresh, Device_OS) |>
slice(1) |>
ungroup()
37 participants (Mean age = 26.7, SD = 7.7, range: [19, 60]; Sex: 40.5% females, 54.1% males, 5.4% other; Education: Master, 21.62%; Bachelor, 32.43%; High School, 43.24%; Other, 2.70%)
plot_distribution <- function(dfsub, what = "Age", title = what, subtitle = "", fill = "orange") {
dfsub |>
ggplot(aes_string(x = what)) +
geom_density(fill = fill) +
geom_vline(xintercept = mean(dfsub[[what]]), color = "red", linetype = "dashed") +
scale_x_continuous(expand = c(0, 0)) +
scale_y_continuous(expand = c(0, 0)) +
ggtitle(title, subtitle = subtitle) +
theme_modern() +
theme(
plot.title = element_text(face = "bold", hjust = 0.5),
plot.subtitle = element_text(face = "italic", hjust = 0.5),
axis.title.x = element_blank(),
axis.title.y = element_blank(),
axis.text.y = element_blank()
)
}
plot_waffle <- function(dfsub, what = "Nationality") {
ggwaffle::waffle_iron(dfsub, what) |>
# mutate(label = emojifont::fontawesome('fa-twitter')) |>
ggplot(aes(x, y, fill = group)) +
ggwaffle::geom_waffle() +
# geom_point() +
# geom_text(aes(label=label), family='fontawesome-webfont', size=4) +
coord_equal() +
ggtitle(what) +
labs(fill = "") +
theme_void() +
theme(plot.title = element_text(face = "bold", hjust = 0.5))
}
p1 <- plot_distribution(dfsub, "Age", fill = "#FF9800")
p2 <- plot_distribution(dfsub, "Duration", title = "Total Duration", subtitle = "in minutes", fill = "#F44336")
p3 <- plot_distribution(dfsub, "Break_Duration", title = "Break Duration", subtitle = "in minutes", fill = "#3F51B5")
p4 <- plot_waffle(dfsub, "Sex") +
scale_fill_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63", "Other" = "#FF9800"))
p5 <- plot_waffle(dfsub, "Education") +
scale_fill_viridis_d()
p6 <- plot_waffle(dfsub, "Nationality") +
scale_fill_metro_d()
p7 <- plot_waffle(dfsub, "Ethnicity") +
scale_fill_manual(values = c("Latino" = "#FF5722", "Asian" = "#FF9800", "Caucasian" = "#2196F3", "African" = "#4CAF50", "Jewish" = "#9C27B0"))
p8 <- plot_waffle(dfsub, "Screen_Resolution") +
scale_fill_pizza_d()
p9 <- plot_waffle(dfsub, "Device_OS") +
scale_fill_bluebrown_d()
# p10 <- plot_waffle(dfsub, "Screen_Refresh") +
# scale_fill_viridis_d()
(p1 / p2 / p3) | (p4 / p5 / p6) | (p7 / p8 / p9)